home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / plisp.emc < prev    next >
Lisp/Scheme  |  1992-06-17  |  16KB  |  496 lines
  1. #include "mp_arith.h"
  2. #include "mp_type.h"
  3.  
  4. (defmodule plisp (standard0 plural plisp-ll) ()
  5.  
  6.   (setq MP-Config 512)
  7.   (setq GC-TOP (mp-sb-ref))
  8.     
  9.  
  10.   (defclass xec ()
  11.     ((context
  12.       initarg context
  13.       reader  context)
  14.      (offset
  15.       initarg offset
  16.       reader  offset))
  17.     constructor (allocate-xec context offset)
  18.     predicate xecp)
  19.  
  20.   (defun make-xec (c o)
  21.     (become-strange (allocate-xec c o)))
  22.   
  23.   (defmethod generic-prin ((p xec) str)
  24.     (format str "#x(")
  25.     (mp-print (context p) (offset p) str)
  26.     (format str ")")
  27.     p)
  28.   
  29.   (defmethod generic-write ((p xec) str)
  30.     (format str "#x(")
  31.     (mp-print (context p) (offset p) str)
  32.     (format str ")")
  33.     p)
  34.  
  35.   (defclass mp-object ()
  36.     ((contexts 
  37.      initarg contexts
  38.      reader  contexts)
  39.     (offsets
  40.      initarg offsets
  41.      accessor offsets)
  42.     (index
  43.      initarg index
  44.      accessor index)
  45.     (shape
  46.      initarg shape
  47.      accessor shape))
  48.     predicate mp-object-p)
  49.  
  50.   
  51.   (defclass field (mp-object)
  52.     ()
  53.     constructor (allocate-field contexts offsets index shape)
  54.     predicate fieldp)
  55.  
  56.   (defun make-field (c o i s)
  57.     (become-strange (allocate-field c o i s)))
  58.   
  59.   (defmethod generic-prin ((f field) str)
  60.     (format str "#F(")
  61.     (mapcar (lambda (c o) (mp-print c o str)) (contexts f) (offsets f))
  62.     (format str ")")
  63.     f)
  64.   
  65.   (defmethod generic-write ((f field) str)
  66.     (format str "#F(")
  67.     (mapcar (lambda (c o) (mp-print c o str)) (contexts f) (offsets f))
  68.     (format str ")")
  69.     f)
  70.   
  71. ; if something is not a partial paralation, it is a global paralation,
  72. ; we can use the same one I think, as long as operations are independent.
  73. ; which I think they are though this will run into trouble with 
  74. ; recursive elwises.
  75.   
  76.   (setq MP-Context (mp-make-context MP-Config))
  77.   (setq MP-Offsets (cons (mp-make-plural MP-Context) ()))
  78.  
  79.   (setq MP-Nil (mp-bang MP-Context ()))
  80.  
  81.   (setq GC-Protect (list (make-xec MP-Context (car MP-Offsets))
  82.              (make-xec MP-Context MP-Nil)))
  83.  
  84.   (defun number-segment (ctxt ofst start size)
  85.     (format t "Renumber: start=~a size=~a\n" start size)
  86.     (labels ((recurse (i)
  87.              (if (< i (- size start)) (recurse (+ i 1)) ())
  88.                (mp-set ctxt ofst i (+ start i))))
  89.       (recurse 0)))
  90.   
  91.   (number-segment MP-Context (car MP-Offsets) 0 MP-Config)
  92.   
  93.   (defun number-segment (ctxt ofst start size)
  94.     (mp-bin-op ctxt (car MP-Offsets) 
  95.     (mp-bang ctxt (- start (cm-start ctxt))) MP_PLUS))
  96.   
  97.   (setq VMP-Config MP-Config)
  98.   (setq PMP-Config (mp-bang MP-Context MP-Config))
  99.  
  100.   (setq GC-Protect (cons (make-xec MP-Context PMP-Config) GC-Protect))
  101.   
  102.   (defun enough-virtual-pes-p 
  103.     (required) (< required (+ VMP-Config MP-Config)))
  104.   
  105.   (defun more-processors (required)
  106.     (labels ((find-last (offsets)
  107.                (if (cdr offsets) (find-last (cdr offsets))
  108.              ((setter cdr) offsets (make-rest (car offsets)))))
  109.              (make-rest (offset)
  110.            (if (enough-virtual-pes-p required) ()
  111.              (let ((new-ofst (mp-bin-op MP-Context offset PMP-Config MP_PLUS)))
  112.            (setq VMP-Config (+ VMP-Config MP-Config))
  113.          (setq GC-Protect (cons (make-xec MP-Context new-ofst)
  114.                     GC-Protect))
  115.            (cons new-ofst (make-rest new-ofst))))))
  116.       (find-last MP-Offsets)))
  117.   
  118.   (defun allocate-processors (required)
  119.     (if (not (enough-virtual-pes-p required)) (more-processors required) ())
  120.     (labels ((list-of-ctxts (allocated)
  121.                (if (>= (+ allocated MP-Config) required)
  122.              (list (mp-make-context (- required allocated)))
  123.              (cons MP-Context (list-of-ctxts (+ allocated MP-Config)))))
  124.              (list-of-ofsts (contexts offsets allocated)
  125.            (cond 
  126.             ((null contexts) ())
  127.             ((eq (car contexts) MP-Context)
  128.              (cons (car offsets) 
  129.                (list-of-ofsts (cdr contexts) (cdr offsets)
  130.                       (+ allocated MP-Config))))
  131.             (t (list (number-segment (car contexts)
  132.                          (mp-make-plural (car contexts))
  133.                          allocated required))))))
  134.       (let* ((contexts (list-of-ctxts 0))
  135.              (offsets  (list-of-ofsts contexts MP-Offsets 0)))
  136.       (make-field contexts offsets () ()))))
  137.  
  138.   (defcondition illegal-operation ())
  139.  
  140.   (defun make-paralation (size)
  141.     (if (< size 1) (error "Attempt to create empty paralation" illegal-operation)
  142.       (let ((new-field (allocate-processors size)))
  143.     ((setter index) new-field new-field)
  144.     new-field)))
  145.  
  146.   (defun field-ref (f i)
  147.     (let ((list-index (/ i MP-Config)))
  148.       (mp-ref (list-ref (contexts f) list-index)
  149.           (list-ref (offsets f) list-index) (remainder i MP-Config))))
  150.  
  151.   ((setter setter) field-ref (lambda (f i v)
  152.      (let ((list-index (/ i MP-Config)))
  153.        (mp-set (list-ref (contexts f) list-index)
  154.            (list-ref (offsets f) list-index) (remainder i MP-Config) v)
  155.        f)))
  156.  
  157.   (defun field-length (f)
  158.     (let ((ll (list-length (contexts  f))))
  159.       (+ (* (if (> ll 1) (- ll 1) 0) MP-Config) 
  160.      (mp-length (list-ref (contexts f) (- ll 1))))))
  161.  
  162. ; This implementation of paralation lisp is based on an existing 
  163. ; version of CM Lisp, in which most of the parallel operations are done
  164. ; in a global context called everywhere. I am going to attempt to use
  165. ; a similar system, but when performing a parallel operation we set
  166. ; the "global" context, THE-CONTEXT,  to be that of the current paralation
  167.   
  168. ; Primitives
  169. ; ==========
  170.  
  171.   (p-1-fn mp-un-op negate MP_NEGATE)
  172.   (p-1-fn mp-un-op abs MP_ABS)
  173.   (p-2-fn mp-eq eq ())
  174.   (p-2-fn mp-cons cons ())
  175.   (p-1-fn mp-car car ())
  176.   (p-1-fn mp-cdr cdr ())
  177.   (p-1-fn mp-make-vector make-vector())
  178.   (p-1-fn mp-vector-length vector-length ())
  179.   (p-2-fn mp-vector-ref vector-ref ())
  180.   (p-1-fn mp-test consp MP_CONS)
  181.   (p-1-fn mp-test intp INTEGER)
  182.   (p-1-fn mp-test floatp MP_FLOAT)
  183.   (p-1-fn mp-test vectorp MP_VECTOR)
  184.   (p-2-fn mp-bin-op binary-plus MP_PLUS)
  185.   (p-2-fn mp-bin-op + MP_PLUS)
  186.   (p-2-fn mp-bin-op binary-difference MP_DIFFERENCE)
  187.   (p-2-fn mp-bin-op - MP_DIFFERENCE)
  188.   (p-2-fn mp-bin-op binary-times MP_TIMES)
  189.   (p-2-fn mp-bin-op * MP_TIMES)
  190.   (p-2-fn mp-bin-op binary-divide MP_DIVIDE)
  191.   (p-2-fn mp-bin-op / MP_DIVIDE)
  192.   (p-2-fn mp-rel-op binary-gt MP_GT)
  193.   (p-2-fn mp-rel-op > MP_GT)
  194.   (p-2-fn mp-rel-op binary-lt MP_LT)
  195.   (p-2-fn mp-rel-op < MP_LT)
  196.   (p-2-fn mp-bin-op remainder MP_REMAINDER)
  197.   (p-0-fn mp-random c-rand ())
  198.   (p-2-fn mp-and and ())
  199.   (p-2-fn mp-or or ())
  200.   (p-1-fn mp-not not ())
  201.   
  202.   (p-2-fn mp-assign setq ())
  203.  
  204.   (p-3-set mp-vector-set vector-ref ())
  205.   (p-2-set mp-rplac-a car ())
  206.   (p-2-set mp-rplac-d cdr ())
  207.  
  208. ; There are a few lisp functions who work in parallel - this is a hack!
  209.  
  210.   ((setter table-ref) pfun-table 'progn (cons 'progn ()))
  211.  
  212.  
  213. ; Elwise
  214. ; ======
  215.  
  216. ; A few everywhere things are still useful
  217.  
  218.   (setq The-Context 'none)
  219.  
  220.   (defun Set-The-Context (v) (setq The-Context v))
  221.  
  222.   (defun rewire (form)
  223.     (cond 
  224.      ((consp form)
  225.       (cond
  226.        ((eq (car form) 'quote) (list 'mp-bang 'The-Context form))
  227.        ((eq (car form) (car function-name)) (cons (cadr function-name)
  228.                           (rewire (cdr form))))
  229.        ((eq (car form) 'if) (elwise-if (cadr form) (caddr form) (cadddr form)))
  230.        ((eq (car form) 'setter) (car (get-psetter (cadr form))))
  231.        ((eq (car form) 'cond) (cons 'let (cons '((cond-result 
  232.                         (mp-make-plural The-Context)))
  233.                     (cons '(mp-if The-Context (mp-bang The-Context t))
  234.                       (rewire-cond (cdr form))))))
  235.        ((eq (car form) 'lambda) (rewire-lambda (cdr form)))
  236.        ((eq (car form) 'let) (rewire-let (cdr form)))
  237.        (t (cons (if (car form) (rewire (car form)) MP-Nil)
  238.         (rewire (cdr form))))))
  239.      ((numberp form) (list 'mp-bang 'The-Context form))
  240.      ((memq form arg-list) form)
  241.      ((get-pfun form) (car (get-pfun form)))
  242.      ((null form) ())
  243.      (t (list 'mp-bang 'The-Context form))))
  244.  
  245.   (defun rewire-cond (form)
  246.     (if (null form) '((mp-fi The-Context) cond-result)
  247.       (cons
  248.        (list 'if (list 'mp-if 'The-Context (rewire (caar form)))
  249.          (list 'mp-assign 'The-Context 
  250.            'cond-result(rewire (cadar form))) ())
  251.        (cons '(mp-file The-Context)
  252.          (rewire-cond (cdr form))))))
  253.        
  254.   (defun rewire-let (form)
  255.     (let ((old-arg-list arg-list))
  256.       (setq arg-list (append (mapcar car (car form)) arg-list))
  257.       (let ((r-form (list 'let (mapcar (lambda (n-f-p)
  258.                      (cons (car n-f-p) 
  259.                            (rewire (cdr n-f-p))))
  260.                        (car form)) (cons 'progn (mapcar rewire 
  261.                                (cdr form))))))
  262.     (setq arg-list old-arg-list)
  263.     r-form)))
  264.  
  265.   (defun rewire-lambda (form)
  266.     (let ((old-arg-list arg-list))
  267.       (setq arg-list (append (car form) arg-list))
  268.       (let ((r-form (list 'lambda (car form) (rewire (cadr form)))))
  269.     (setq arg-list old-arg-list)
  270.     r-form)))
  271.  
  272.   (defun elwise-if (bool then else)
  273.     (let ((then (if then (rewire then) MP-Nil))
  274.       (else (if else (rewire else) MP-Nil)))
  275.       (list 'let '((if-result (mp-make-plural The-Context)))
  276.         (list 'if (list 'mp-if 'The-Context (rewire bool))
  277.           (list 'mp-assign 'The-Context 'if-result then) ())
  278.         (list 'if (list 'mp-else 'The-Context)
  279.           (list 'mp-assign 'The-Context 'if-result else) ())
  280.         '(mp-fi The-Context)
  281.         'if-result)))
  282.  
  283.   (defun eval-arg-list (arg-form)
  284.     (if (null arg-form) (list (list 'the-contexts 
  285.                     (list 'contexts (car arg-list)))
  286.                   (list 'the-index (list 'index (car arg-list)))
  287.                   (list 'the-shape (list 'shape (car arg-list)))
  288.                   '(the-offsets (mapcar mp-make-plural the-contexts))
  289.                   '(the-result (make-field the-contexts the-offsets the-index the-shape)))
  290.       (if (consp (car arg-form))
  291.         (progn 
  292.           (setq arg-list (cons (caar arg-form) arg-list))
  293.           (cons (car arg-form) (eval-arg-list (cdr arg-form))))
  294.         (progn 
  295.           (setq arg-list (cons (car arg-form) arg-list))
  296.           (eval-arg-list (cdr arg-form))))))
  297.  
  298.   (defun get-offsets (arg-list) 
  299.     (mapcar (lambda (f) (list `offsets f)) arg-list))
  300.  
  301.   (defmacro elwise (arg-form body)
  302.     (setq arg-list ())
  303.     (setq function-name '(none))
  304.     `(let* ,(eval-arg-list arg-form)
  305.        (mapcar (lambda ,(cons `the-context 
  306.                   (cons 'result-ofst arg-list))
  307.          (let ((tmp-pspace (mp-ps-ref)))
  308.            (mp-sb-set tmp-pspace)
  309.            (Set-The-Context the-context)
  310.            (mp-assign The-Context result-ofst
  311.                   ,(if body (rewire body) 
  312.                  (list 'mp-bang 'The-Context ())))
  313.            (mp-sb-set GC-TOP)
  314.            (mp-ps-set tmp-pspace)
  315.            result-ofst))
  316.            ,@(cons `the-contexts (cons `the-offsets 
  317.                        (get-offsets arg-list))))
  318.        the-result))
  319.        
  320.  
  321.  
  322.  
  323. ; to add primitives, particularly recursive primitives
  324.  
  325.   (defmacro depfun (name args body)
  326.     (setq arg-list args)
  327.     (setq function-name (list name (make-pfun-name name)))
  328.     (add-pfun name (cadr function-name) args)
  329.     `(progn (defun ,(cadr function-name) ,args ,(rewire body))
  330.         (export ,(cadr function-name))))
  331.  
  332. (defclass mapping (mp-object)
  333.   ()
  334.   constructor (make-mapping contexts offsets index shape)
  335.   predicate mappingp)
  336.  
  337. (defun allocate-mapping (c o i s)
  338.   (become-strange (make-mapping c o i s)))
  339.  
  340. ; It seems a non-trivial task to make this GC safe
  341.  
  342. (defun match (dest from)
  343.   (let ((result (allocate-mapping 
  344.          (contexts dest) (mapcar (lambda (d-c) 
  345.                        (mapcar (lambda (f-c) 
  346.                              (mp-make-plural d-c))
  347.                            (contexts from)))
  348.                      (contexts dest))
  349.          (index dest) (shape dest)))
  350.     (tmp-pspace (mp-ps-ref)))
  351.     (mp-sb-set tmp-pspace)
  352.     (labels ((seg-match (d-ctxt d-ofst r-ofsts ctxts ofsts)
  353.             (if (null ctxts) ()
  354.               (progn 
  355.                 (mp-assign d-ctxt (car r-ofsts) 
  356.                        (mp-match d-ctxt d-ofst 
  357.                          (car ctxts) (car ofsts)))
  358.                 (seg-match d-ctxt d-ofst (cdr r-ofsts)
  359.                         (cdr ctxts) (cdr ofsts))))))
  360.       (mapcar (lambda (c o r) 
  361.         (seg-match c o r (contexts from) (offsets from)))
  362.           (contexts dest) (offsets dest) (offsets result))
  363.       (mp-ps-set tmp-pspace)
  364.       (mp-sb-set GC-TOP)
  365.       result)))
  366.  
  367. ; Don't think this needs any protection the mpl protection (which I have yet to
  368. ; put in should be sufficient
  369.  
  370. (defun ll-move (data map)
  371.   (let ((initial (mapcar mp-make-plural (contexts map))))
  372.     (mapcar
  373.      (lambda (m-ctxt m-ofsts i-ofst)
  374.        (mapcar (lambda (d-ctxt d-ofst m-ofst)
  375.          (mp-move d-ctxt d-ofst m-ctxt m-ofst i-ofst))
  376.            (contexts data) (offsets data) m-ofsts))
  377.      (contexts map) (offsets map) initial)
  378.     initial))
  379.  
  380. (defmacro move (data map with default)
  381.   `(l-move ,data ,map ,(if (not (consp with)) (car (get-pfun with))
  382.              (progn
  383.                (setq arg-list (cadr with))
  384.                (list 'lambda arg-list (rewire (caddr with)))))
  385.       ,default))
  386.  
  387. (defun l-move (data map p-with default)
  388.     (labels  ((recurse (l-ofst cdrl-ofst r-ofst)
  389.         (if (mp-if The-Context cdrl-ofst)
  390.           (mp-assign The-Context r-ofst
  391.                  (p-with (mp-car The-Context l-ofst)
  392.                    (recurse cdrl-ofst 
  393.                         (mp-cdr The-Context cdrl-ofst)
  394.                         r-ofst))) ())
  395.         (mp-else The-Context)
  396.         (mp-assign The-Context r-ofst (mp-car The-Context l-ofst))
  397.         (mp-fi The-Context)
  398.         r-ofst))
  399.        (let ((result (make-field (contexts map) 
  400.                  (mapcar mp-make-plural (contexts map))
  401.                  (index map) (shape map))))
  402.       (mapcar (lambda (ctxt ofst r-ofst)
  403.             (let ((tmp-pspace (mp-ps-ref)))
  404.               (mp-sb-set tmp-pspace)
  405.               (Set-The-Context ctxt)
  406.               (mp-if ctxt ofst)
  407.               (recurse ofst (mp-cdr The-Context ofst) r-ofst)
  408.               (mp-else ctxt)
  409.               (mp-assign ctxt r-ofst (mp-bang ctxt default))
  410.               (mp-fi ctxt)
  411.               (mp-sb-set GC-TOP)
  412.               (mp-ps-set tmp-pspace)
  413.               r-ofst))
  414.           (contexts map) (ll-move data map) (offsets result))
  415.       result)))
  416.       
  417. (defun get (direction f default)
  418.   (let ((map (vector-ref (shape f) direction))
  419.     (result (make-field (contexts f) (mapcar mp-make-plural (contexts f))
  420.                 (index f) (shape f))))
  421.     (mapcar (lambda (c o r-o)
  422.           (let ((tmp-pspace (mp-ps-ref)))
  423.         (mp-sb-set tmp-pspace)
  424.         (mp-if c o) (mp-assign c r-o (mp-car c o))
  425.         (mp-else c) (mp-assign c r-o (mp-bang c default))
  426.         (mp-fi c)
  427.         (mp-sb-set GC-TOP)
  428.         (mp-ps-set tmp-pspace) r-o)) 
  429.           (contexts f) (ll-move f map) (offsets result))
  430.     result))
  431.  
  432. (defun enum-ll (bool-f)
  433.   (let ((result (elwise (bool-f) (if bool-f 1 0)))
  434.     (tmp-pspace (mp-ps-ref)))
  435.     (labels ((recurse (c-s o-s s)
  436.          (if (null c-s) ()
  437.            (progn
  438.              (mp-assign (car c-s) (car o-s) 
  439.                 (mp-bin-op (car c-s) 
  440.                        (mp-scan-op (car c-s) 
  441.                                (car o-s) MP_PLUS)
  442.                        (mp-bang (car c-s) s) MP_PLUS))
  443.              (recurse (cdr c-s) (cdr o-s)
  444.                   (mp-ref (car c-s) (car o-s)
  445.                       (- (mp-length (car c-s)) 1)))))))
  446.       (mp-sb-set tmp-pspace)
  447.       (recurse (contexts result) (offsets result) 0)
  448.       (mp-ps-set tmp-pspace)
  449.       (mp-sb-set GC-TOP)
  450.       result)))
  451.         
  452. (defun enum (bool-f)
  453.   (elwise (bool-f (new (enum-ll bool-f))) (if bool-f (- new 1) ())))
  454.  
  455. (defun choose (bool-f)
  456.   (let ((tmp (enum-ll bool-f)))
  457.     (match (make-paralation (field-ref tmp (- (field-length bool-f) 1)))
  458.        (elwise (tmp bool-f) (if bool-f (- tmp 1) ())))))
  459.  
  460. (defun count (bool-f)
  461.   (field-ref (enum-ll bool-f) (- (field-length bool-f) 1)))
  462.  
  463. (defun position (f o)
  464.   (let* ((tmp (elwise (f (i (index f))) (if (eq f o) i ())))
  465.      (tmp-pspace (mp-ps-ref))
  466.      (t-o (progn (mp-sb-set tmp-pspace) (mp-bang MP-Context 32768))))
  467.     (labels ((recurse (c-s o-s)
  468.           (cond
  469.            ((null c-s) ())
  470.            ((not (mp-if (car c-s) (car o-s)))
  471.         (progn (mp-fi (car c-s)) 
  472.                (recurse (cdr c-s) (cdr o-s))))
  473.            (t (progn
  474.             (mp-assign (car c-s) t-o (car o-s))
  475.             (mp-fi (car c-s))
  476.             (mp-ref (car c-s) (mp-scan-op (car c-s) t-o MP_MIN)
  477.                 (- (mp-length (car c-s)) 1)))))))
  478.       (let ((result (recurse (contexts f) (offsets tmp))))
  479.     (mp-sb-set GC-TOP)
  480.     (mp-ps-set tmp-pspace)
  481.     result))))
  482.  
  483. ; Vref
  484.  
  485. ; We want to create a map which will shift everything left in the global
  486. ; context, this can be used by all other contexts to the same effect
  487.  
  488.       
  489. (export depfun elwise match move make-paralation field-ref contexts offsets
  490.         index shape make-field Set-The-Context The-Context GC-TOP position
  491.     l-move choose enum count get fieldp field-length
  492.     allocate-xec rewire)
  493.  
  494. )
  495.  
  496.